home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / heap.c < prev    next >
C/C++ Source or Header  |  1991-10-11  |  55KB  |  1,911 lines
  1. /* SCHEME->C */
  2.  
  3. /*              Copyright 1989 Digital Equipment Corporation
  4.  *                         All Rights Reserved
  5.  *
  6.  * Permission to use, copy, and modify this software and its documentation is
  7.  * hereby granted only under the following terms and conditions.  Both the
  8.  * above copyright notice and this permission notice must appear in all copies
  9.  * of the software, derivative works or modified versions, and any portions
  10.  * thereof, and both notices must appear in supporting documentation.
  11.  *
  12.  * Users of this software agree to the terms and conditions set forth herein,
  13.  * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14.  * right and license under any changes, enhancements or extensions made to the
  15.  * core functions of the software, including but not limited to those affording
  16.  * compatibility with other hardware or software environments, but excluding
  17.  * applications which incorporate this software.  Users further agree to use
  18.  * their best efforts to return to Digital any such changes, enhancements or
  19.  * extensions that they make and inform Digital of noteworthy uses of this
  20.  * software.  Correspondence should be provided to Digital at:
  21.  * 
  22.  *                       Director of Licensing
  23.  *                       Western Research Laboratory
  24.  *                       Digital Equipment Corporation
  25.  *                       100 Hamilton Avenue
  26.  *                       Palo Alto, California  94301  
  27.  * 
  28.  * This software may be distributed (but not offered for sale or transferred
  29.  * for compensation) to third parties, provided such third parties agree to
  30.  * abide by the terms and conditions of this notice.  
  31.  * 
  32.  * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33.  * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34.  * MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35.  * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36.  * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37.  * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38.  * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39.  * SOFTWARE.
  40. */
  41.  
  42. /* This module implements the object storage storage system. */
  43.  
  44. /* Import definitions */
  45.  
  46. #include "objects.h"
  47. #include "scinit.h"
  48. #include "heap.h"
  49. #include "callcc.h"
  50. #include "signal.h"
  51. #include "apply.h"
  52. extern  abort();
  53. #ifdef GGC
  54. #include "GGC.h"
  55. #endif
  56. #ifdef MIPS
  57. extern  sc_s0tos8();
  58. #endif
  59. #ifdef VAX
  60. extern  sc_r2tor11();
  61. #endif
  62. #ifdef APOLLO
  63. extern sc_regs();
  64. #endif
  65. #ifdef SUN3
  66. extern    sc_a2to5d2to7();
  67. #endif
  68.  
  69. /* Forward declarations */
  70.  
  71. extern int  move_ptr();
  72.  
  73. extern SCP  move_object();
  74.  
  75. /* Allocate storage which is defined in "heap.h" */
  76.  
  77. int      *sc_pagegeneration,    /* page generation table */
  78.     *sc_pagetype,        /* page type table */
  79.     *sc_pagelock,        /* page lock table */
  80.     *sc_pagelink,        /* page lock list link table */
  81.     sc_initiallink,        /* Value to put in sc_pagelink field for a
  82.                    newly allocated page */
  83.     sc_locklist,        /* list header for locked pages */
  84.     sc_genlist,        /* list of modified pages */
  85.     sc_lockcnt,        /* # of locked pages */
  86.     sc_current_generation,  /* current generation */
  87.     sc_next_generation;    /* next generation */
  88.  
  89. int    sc_firstheappage,    /* first page in the Scheme heap */
  90.     sc_lastheappage,    /* last page in the Scheme heap  */
  91.     sc_limit,        /* % of heap allocated after collecton
  92.                    that forces total collection */
  93.     sc_freepage,        /* free page index */
  94.     sc_heappages,        /* # of pages in the Scheme heap */
  95.     sc_allocatedheappages,  /* # of pages currently allocated */
  96.     sc_generationpages,    /* # of pages in saved generations */
  97.     *sc_firstheapp,        /* ptr to first word in the Scheme heap */
  98.     *sc_lastheapp;        /* ptr to last word in the Scheme heap */
  99.  
  100. int    sc_conscnt;        /* # cons cells in sc_consp */
  101. SCP    sc_consp;        /* pointer to next cons cell */
  102.  
  103. int    sc_extobjwords,        /* # of words for ext objs in sc_extobjp */
  104.     sc_extwaste;        /* # of words wasted on page crossings */
  105. SCP    sc_extobjp;        /* pointer to next free extended obj word */
  106.  
  107. int    sc_gcinfo;        /* controls logging */
  108.  
  109. #ifndef    NO_RUSAGE
  110. static struct rusage gcru,    /* resource consumption during collection */
  111.                  startru,
  112.                    stopru;
  113. #endif
  114.  
  115. int    *sc_stackbase;        /* pointer to base of the stack */
  116.  
  117. TSCP    sc_whenfreed,        /* list of items needing cleanup when free */
  118.     sc_freed;        /* list of free items to be cleanup */
  119.  
  120. TSCP    sc_after_2dcollect_v;    /* Collection status callback */
  121.  
  122. #ifndef NO_RUSAGE
  123. /* The following function converts a rusage structure into an 18 word Scheme
  124.    vector composed of the same items.
  125. */
  126.  
  127. static TSCP  rusagevector( ru )
  128.     struct rusage *ru;
  129. {
  130.     TSCP  v;
  131.     PATSCP  ve;
  132.  
  133.     v = sc_make_2dvector( C_FIXED( 18 ), EMPTYLIST );
  134.     ve = &(T_U( v )->vector.element0);
  135.     *ve++ = C_FIXED( ru->ru_utime.tv_sec );
  136.     *ve++ = C_FIXED( ru->ru_utime.tv_usec );
  137.     *ve++ = C_FIXED( ru->ru_stime.tv_sec );
  138.     *ve++ = C_FIXED( ru->ru_stime.tv_usec );
  139.     *ve++ = C_FIXED( ru->ru_maxrss );
  140.     *ve++ = C_FIXED( ru->ru_ixrss );
  141.         *ve++ = C_FIXED( ru->ru_idrss );
  142.         *ve++ = C_FIXED( ru->ru_isrss );
  143.         *ve++ = C_FIXED( ru->ru_minflt );
  144.         *ve++ = C_FIXED( ru->ru_majflt );
  145.         *ve++ = C_FIXED( ru->ru_nswap );
  146.         *ve++ = C_FIXED( ru->ru_inblock );
  147.         *ve++ = C_FIXED( ru->ru_oublock );
  148.         *ve++ = C_FIXED( ru->ru_msgsnd );
  149.         *ve++ = C_FIXED( ru->ru_msgrcv );
  150.     *ve++ = C_FIXED( ru->ru_nsignals );
  151.     *ve++ = C_FIXED( ru->ru_nvcsw );
  152.     *ve++ = C_FIXED( ru->ru_nivcsw );
  153.     return( v );
  154. }
  155.  
  156. /* Garbage collector resource usage is accumulated by the following function.
  157.    It will accumlate the resources used in gcru, and change stopru to reflect
  158.    the resource usage this collection.
  159. */
  160.  
  161. static updategcru()
  162. {
  163.     int  x;
  164.  
  165.     /* Compute deltas in stopru */
  166.     if  (stopru.ru_utime.tv_usec < startru.ru_utime.tv_usec)  {
  167.        stopru.ru_utime.tv_sec = stopru.ru_utime.tv_sec-
  168.                     startru.ru_utime.tv_sec-1;
  169.        stopru.ru_utime.tv_usec = 1000000+stopru.ru_utime.tv_usec-
  170.                         startru.ru_utime.tv_usec;
  171.     }
  172.     else  {
  173.        stopru.ru_utime.tv_sec = stopru.ru_utime.tv_sec-
  174.                     startru.ru_utime.tv_sec;
  175.        stopru.ru_utime.tv_usec = stopru.ru_utime.tv_usec-
  176.                      startru.ru_utime.tv_usec;
  177.     }       
  178.     if  (stopru.ru_stime.tv_usec < startru.ru_stime.tv_usec)  {
  179.        stopru.ru_stime.tv_sec = stopru.ru_stime.tv_sec-
  180.                     startru.ru_stime.tv_sec-1;
  181.        stopru.ru_stime.tv_usec = 1000000+stopru.ru_stime.tv_usec-
  182.                         startru.ru_stime.tv_usec;
  183.     }
  184.     else  {
  185.        stopru.ru_stime.tv_sec = stopru.ru_stime.tv_sec-
  186.                     startru.ru_stime.tv_sec;
  187.        stopru.ru_stime.tv_usec = stopru.ru_stime.tv_usec-
  188.                      startru.ru_stime.tv_usec;
  189.     }
  190.     stopru.ru_minflt -= startru.ru_minflt;
  191.     stopru.ru_majflt -= startru.ru_majflt;
  192.     stopru.ru_nswap -= startru.ru_nswap;
  193.     stopru.ru_inblock -= startru.ru_inblock;
  194.     stopru.ru_oublock -= startru.ru_oublock;
  195.     stopru.ru_msgsnd -= startru.ru_msgsnd;
  196.     stopru.ru_msgrcv -= startru.ru_msgrcv;
  197.     stopru.ru_nsignals -= startru.ru_nsignals;
  198.     stopru.ru_nvcsw -= startru.ru_nvcsw;
  199.     stopru.ru_nivcsw -= startru.ru_nivcsw;
  200.  
  201.     /* Accumulate totals in gcru */
  202.     x = gcru.ru_utime.tv_usec+stopru.ru_utime.tv_usec;
  203.     gcru.ru_utime.tv_usec = x % 1000000;
  204.     gcru.ru_utime.tv_sec = gcru.ru_utime.tv_sec+stopru.ru_utime.tv_sec+
  205.                    x / 1000000;
  206.     x = gcru.ru_stime.tv_usec+stopru.ru_stime.tv_usec;
  207.     gcru.ru_stime.tv_usec = x % 1000000;
  208.     gcru.ru_stime.tv_sec = gcru.ru_stime.tv_sec+stopru.ru_stime.tv_sec+
  209.                    x / 1000000;
  210.     gcru.ru_maxrss = stopru.ru_maxrss;
  211.     gcru.ru_ixrss = stopru.ru_ixrss;
  212.     gcru.ru_idrss = stopru.ru_idrss;
  213.     gcru.ru_minflt += stopru.ru_minflt;
  214.     gcru.ru_majflt += stopru.ru_majflt;
  215.     gcru.ru_nswap += stopru.ru_nswap;
  216.     gcru.ru_inblock += stopru.ru_inblock;
  217.     gcru.ru_oublock += stopru.ru_oublock;
  218.     gcru.ru_msgsnd += stopru.ru_msgsnd;
  219.     gcru.ru_msgrcv += stopru.ru_msgrcv;
  220.     gcru.ru_nsignals += stopru.ru_nsignals;
  221.     gcru.ru_nvcsw += stopru.ru_nvcsw;
  222.     gcru.ru_nivcsw += stopru.ru_nivcsw;
  223. }
  224.     
  225. /* The following function returns the resource usage information for the
  226.    process.  It returns a vector formed of the elements in the rusage struct
  227.    returned by getrusage.  It is visible in Scheme as (MY-RUSAGE).  
  228. */
  229.  
  230. TSCP  sc_my_2drusage_v;
  231.  
  232. TSCP  sc_my_2drusage()
  233. {
  234.     struct rusage ru;
  235.  
  236.     getrusage( 0, &ru );
  237.     return( rusagevector( &ru ) );
  238. }
  239.  
  240. /* The following function returns the resource usage information for the
  241.    garbage collector.  It returns a vector formed of the elements in the rusage
  242.    struct maintained by the collector.  It is visible in Scheme as
  243.    (COLLECT-RUSAGE).
  244. */
  245.  
  246. TSCP  sc_collect_2drusage_v;
  247.  
  248. TSCP  sc_collect_2drusage()
  249. {
  250.     return( rusagevector( &gcru ) );
  251. }
  252. #else
  253. #define    getrusage(x,y)    /* no operation */
  254. #define updategcru()    /* no operation */
  255. #endif        /* SYSV-BSD dependency */
  256.  
  257. /* Errors detected during garbage collection are logged by the following
  258.    procedure.  If any errors occur, the program will abort after logging
  259.    them.  More than 30 errors will result in the program being aborted at
  260.    once
  261. */
  262.  
  263. static SCP  moving_object;
  264.  
  265. static int  pointer_errors = 0;
  266.  
  267. static void  pointererror( msg, pp )
  268.     SCP  pp;
  269. {
  270.     fprintf( stderr, "***** COLLECT pointer error in %x, ",
  271.          moving_object );
  272.     fprintf( stderr, msg, pp );
  273.     if  (++pointer_errors == 30)  abort();
  274. }
  275.  
  276. #ifdef TITAN
  277. /* The following function is called to read one of the Titan registers.  It
  278.    must be open-coded using constant register numbers as zzReadRegister is
  279.    actually a Mahler inline function which expects a constant register
  280.    number.
  281. */
  282.  
  283. int  *sc_processor_register( regnum )
  284. {
  285.     switch (regnum)  {
  286.         case  0: return( zzReadRegister(  0 ) ); 
  287.         case  1: return( zzReadRegister(  1 ) ); 
  288.         case  2: return( zzReadRegister(  2 ) ); 
  289.         case  3: return( zzReadRegister(  3 ) ); 
  290.         case  4: return( zzReadRegister(  4 ) ); 
  291.                 case  5: return( zzReadRegister(  5 ) );
  292.                 case  6: return( zzReadRegister(  6 ) );
  293.                 case  7: return( zzReadRegister(  7 ) );
  294.                 case  8: return( zzReadRegister(  8 ) );
  295.                 case  9: return( zzReadRegister(  9 ) );
  296.         case 10: return( zzReadRegister( 10 ) ); 
  297.         case 11: return( zzReadRegister( 11 ) ); 
  298.         case 12: return( zzReadRegister( 12 ) ); 
  299.         case 13: return( zzReadRegister( 13 ) ); 
  300.         case 14: return( zzReadRegister( 14 ) ); 
  301.         case 15: return( zzReadRegister( 15 ) );
  302.         case 16: return( zzReadRegister( 16 ) );
  303.         case 17: return( zzReadRegister( 17 ) );
  304.         case 18: return( zzReadRegister( 18 ) );
  305.         case 19: return( zzReadRegister( 19 ) );
  306.         case 20: return( zzReadRegister( 20 ) ); 
  307.         case 21: return( zzReadRegister( 21 ) ); 
  308.         case 22: return( zzReadRegister( 22 ) ); 
  309.         case 23: return( zzReadRegister( 23 ) ); 
  310.         case 24: return( zzReadRegister( 24 ) ); 
  311.                 case 25: return( zzReadRegister( 25 ) );
  312.                 case 26: return( zzReadRegister( 26 ) );
  313.                 case 27: return( zzReadRegister( 27 ) );
  314.                 case 28: return( zzReadRegister( 28 ) );
  315.                 case 29: return( zzReadRegister( 29 ) );
  316.         case 30: return( zzReadRegister( 30 ) ); 
  317.         case 31: return( zzReadRegister( 31 ) ); 
  318.         case 32: return( zzReadRegister( 32 ) ); 
  319.         case 33: return( zzReadRegister( 33 ) ); 
  320.         case 34: return( zzReadRegister( 34 ) ); 
  321.         case 35: return( zzReadRegister( 35 ) );
  322.         case 36: return( zzReadRegister( 36 ) );
  323.         case 37: return( zzReadRegister( 37 ) );
  324.         case 38: return( zzReadRegister( 38 ) );
  325.         case 39: return( zzReadRegister( 39 ) );
  326.         case 40: return( zzReadRegister( 40 ) ); 
  327.         case 41: return( zzReadRegister( 41 ) ); 
  328.         case 42: return( zzReadRegister( 42 ) ); 
  329.         case 43: return( zzReadRegister( 43 ) ); 
  330.         case 44: return( zzReadRegister( 44 ) ); 
  331.         case 45: return( zzReadRegister( 45 ) );
  332.         case 46: return( zzReadRegister( 46 ) );
  333.         case 47: return( zzReadRegister( 47 ) );
  334.         case 48: return( zzReadRegister( 48 ) );
  335.         case 49: return( zzReadRegister( 49 ) );
  336.         case 50: return( zzReadRegister( 50 ) ); 
  337.         case 51: return( zzReadRegister( 51 ) ); 
  338.         case 52: return( zzReadRegister( 52 ) ); 
  339.         case 53: return( zzReadRegister( 53 ) ); 
  340.         case 54: return( zzReadRegister( 54 ) ); 
  341.         case 55: return( zzReadRegister( 55 ) );
  342.         case 56: return( zzReadRegister( 56 ) );
  343.         case 57: return( zzReadRegister( 57 ) );
  344.         case 58: return( zzReadRegister( 58 ) );
  345.         case 59: return( zzReadRegister( 59 ) );
  346.         case 60: return( zzReadRegister( 60 ) ); 
  347.         case 61: return( zzReadRegister( 61 ) ); 
  348.         case 62: return( zzReadRegister( 62 ) ); 
  349.         case 63: return( zzReadRegister( 63 ) );
  350.         default: return( 0 );
  351.     }
  352. }
  353.  
  354. /* All processor registers are traced by the following procedure. */
  355.  
  356. static  trace_stack_and_registers()
  357. {
  358.     int  i, *r0tor60[ 61 ], *pp;
  359.  
  360.     for  (i = 0; i <= 60; i++)  r0tor60[ i ] = sc_processor_register( i );
  361.     pp = STACKPTR;
  362.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  363. }
  364. #endif /* TITAN */
  365.  
  366. #ifdef VAX
  367. /* The following code is used to read the stack pointer.  The register
  368.    number is passed in to force an argument to be on the stack, which in
  369.    turn can be used to find the address of the top of stack.
  370. */
  371.  
  372. int  *sc_processor_register( reg )
  373.     int  reg;
  374. {
  375.     return( ®+1 );
  376. }
  377.  
  378. /* All processor registers which might contain pointers are traced by the
  379.    following procedure.
  380. */
  381.  
  382. static  trace_stack_and_registers()
  383. {
  384.     int  i, r2tor11[10], *pp;
  385.  
  386.     sc_r2tor11( r2tor11 );
  387.     pp = STACKPTR;
  388.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  389. }
  390. #endif /* VAX */
  391.  
  392. #ifdef MIPS
  393. /* The following code is used to read the stack pointer.  The register
  394.    number is passed in to force an argument to be on the stack, which in
  395.    turn can be used to find the address of the top of stack.
  396. */
  397.  
  398. int  *sc_processor_register( reg )
  399.     int  reg;
  400. {
  401.     return( ® );
  402. }
  403.  
  404. /* All processor registers which might contain pointers are traced by the
  405.    following procedure.
  406. */
  407.  
  408. static  trace_stack_and_registers()
  409. {
  410.     int  i, s0tos8[9], *pp;
  411.  
  412.     sc_s0tos8( s0tos8 );
  413.     pp = STACKPTR;
  414.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  415. }
  416. #endif /* MIPS */
  417.  
  418. #ifdef APOLLO
  419. /* The following code is used to read the stack pointer.  The register
  420.    number is passed in to force an argument to be on the stack, which in
  421.    turn can be used to find the address of the top of stack.
  422. */
  423.  
  424. int  *sc_processor_register( reg )
  425.     int  reg;
  426. {
  427.     return( ® );
  428. }
  429.  
  430. /* All processor registers that might contain pointers are traced by the
  431.    following procedure.
  432. */
  433.  
  434. static  trace_stack_and_registers()
  435. {
  436.     int  i, a1toa4_d0tod7[12], *pp;
  437.  
  438.     sc_regs( a1toa4_d0tod7 );
  439.     pp = STACKPTR;
  440.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  441. }
  442. #endif /* APOLLO */
  443.  
  444. #ifdef PRISM
  445. /* All processor registers that might contain pointers are traced by the
  446.    following procedure.
  447. */
  448.  
  449. static  trace_stack_and_registers()
  450. {
  451.     int  i, regs[12], *pp;
  452.  
  453.     sc_regs( regs );
  454.     pp = STACKPTR;
  455.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  456. }
  457. #endif /* PRISM */
  458.  
  459. #ifdef SPARC
  460. /* All processor registers which might contain pointers are traced by the
  461.    following procedure.
  462. */
  463.  
  464. static  trace_stack_and_registers()
  465. {
  466.     int  i, *pp;
  467.     jmp_buf tmp;
  468.  
  469.     pp = STACKPTR;
  470.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  471. }
  472. #endif SPARC
  473.  
  474. #ifdef SUN3
  475. /* The following code is used to read the stack pointer.  The register
  476.    number is passed in to force an argument to be on the stack, which in
  477.    turn can be used to find the address of the top of stack.
  478. */
  479.  
  480. int  *sc_processor_register( reg )
  481.     int  reg;
  482. {
  483.     return( ®+1 );
  484. }
  485.  
  486. /* All processor registers which might contain pointers are traced by the
  487.    following procedure.
  488. */
  489.  
  490. static  trace_stack_and_registers()
  491. {
  492.     int  i, a2to5d2to7[10], *pp;
  493.  
  494.     sc_a2to5d2to7( a2to5d2to7 );
  495.     pp = STACKPTR;
  496.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  497. }
  498. #endif SUN3
  499.  
  500.  
  501. #ifdef    AMIGA
  502. /* All processor registers are traced by the following procedure. */
  503.  
  504. static  trace_stack_and_registers()
  505. {
  506.     volatile int d0toa4[ 15 ];
  507.     int *pp;
  508.  
  509.     d0toa4[0] = getreg(0);
  510.     d0toa4[1] = getreg(1);
  511.     d0toa4[2] = getreg(2);
  512.     d0toa4[3] = getreg(3);
  513.     d0toa4[4] = getreg(4);
  514.     d0toa4[5] = getreg(5);
  515.     d0toa4[6] = getreg(6);
  516.     d0toa4[7] = getreg(7);
  517.     d0toa4[8] = getreg(8);
  518.     d0toa4[9] = getreg(9);
  519.     d0toa4[10] = getreg(10);
  520.     d0toa4[11] = getreg(11);
  521.     d0toa4[12] = getreg(12);
  522.     d0toa4[13] = getreg(13);
  523.     d0toa4[14] = getreg(14);
  524.     pp = (short *) STACKPTR;        /* This gets 15 */
  525.     while  (pp != sc_stackbase)
  526.         move_continuation_ptr( *pp++ );
  527. }
  528. #endif
  529.  
  530.  
  531. #ifdef I386
  532. /* The following code is used to read the stack pointer.  The register
  533.    number is passed in to force an argument to be on the stack, which in
  534.    turn can be used to find the address of the top of stack.
  535. */
  536.  
  537. int  *sc_processor_register( reg )
  538.     int  reg;
  539. {
  540.     return( ® );
  541. }
  542.  
  543. /* All processor registers which might contain pointers are traced by the
  544.    following procedure.
  545. */
  546.  
  547. static  trace_stack_and_registers()
  548. {
  549.     int  i, *pp;
  550.     jmp_buf tmp;
  551.  
  552.     setjmp(tmp);
  553.     pp = STACKPTR;
  554.     while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  555. }
  556. #endif I386
  557.  
  558.  
  559. /* The size of an extended object in words is returned by the following
  560.    function.
  561. */
  562.  
  563. static int  extendedsize( obj )
  564.     SCP  obj;
  565. {
  566.     switch  (obj->extendedobj.tag)  {
  567.  
  568.        case  SYMBOLTAG:
  569.           return( SYMBOLSIZE );
  570.  
  571.        case  STRINGTAG:
  572.           return( STRINGSIZE( obj->string.length ) );
  573.  
  574.        case  VECTORTAG:
  575.           return( VECTORSIZE( obj->vector.length ) );
  576.  
  577.        case  PROCEDURETAG:
  578.           return( PROCEDURESIZE );
  579.  
  580.        case  CLOSURETAG:
  581.           return( CLOSURESIZE( obj->closure.length ) );
  582.  
  583.        case  CONTINUATIONTAG:
  584.           return( CONTINUATIONSIZE( obj->continuation.length ) );
  585.  
  586.        case  FLOAT32TAG:
  587.           return( FLOAT32SIZE );
  588.  
  589.        case  FLOAT64TAG:
  590.           return( FLOAT64SIZE );
  591.  
  592.        case  FORWARDTAG:
  593.           return( FORWARDSIZE( obj->forward.length ) );
  594.  
  595.        case  WORDALIGNTAG:
  596.           return( WORDALIGNSIZE );
  597.  
  598.        default:
  599.           fprintf( stderr,
  600.                      "***** COLLECT Unknown extended object: %x %x\n",
  601.                      obj, obj->extendedobj.tag );
  602.           abort();
  603.     }
  604. }
  605.  
  606. /* Words inside continuations are checked by the following function.  If the
  607.    word looks like a pointer, then the page containing the object will be
  608.    locked and the object will be moved.  
  609. */
  610.  
  611. static move_continuation_ptr( pp )
  612.     SCP  pp;
  613. {
  614.     int  page, tag;
  615.     SCP  sweep, next;
  616.  
  617.     if (pp >= (SCP)sc_firstheapp  &&  pp < (SCP)sc_lastheapp)  {
  618.        page = ADDRESS_PAGE( pp );
  619.        if  (sc_current_generation == sc_pagegeneration[ page ])  {
  620.           tag = sc_pagetype[ page ];
  621.           if  (tag == PAIRTAG)  {
  622.              /* Trace just that PAIR */
  623.              pp = (SCP)(((int)pp) & ~(CONSBYTES-1));
  624.          if  (sc_pagelock[ page ] == 0)  {
  625.             sc_pagelock[ page ] = 1;
  626.             sc_pagelink[ page ] = sc_locklist;
  627.             sc_locklist = page;
  628.             sc_lockcnt = sc_lockcnt+1;
  629. #ifdef GGC
  630.             GGCmarkLocked( page, 1 );
  631. #endif
  632.          }
  633.          if  (sc_gcinfo == 2  &&  pp->forward.tag != FORWARDTAG)
  634.             fprintf( stderr,
  635.                      "              move_continuation_ptr %x\n",
  636.                  U_T( pp, PAIRTAG ) );
  637.          move_ptr( U_T( pp, PAIRTAG ) );
  638.          return;
  639.           }
  640.           /* Trace the referenced object */
  641.           if  (tag == BIGEXTENDEDTAG)  {
  642.           while (sc_pagetype[ page ] != EXTENDEDTAG)  page--;
  643.           }
  644.           sweep = (SCP)PAGE_ADDRESS( page );
  645.           if  (sc_pagelock[ page ] == 0)  {
  646.          sc_pagelock[ page ] = 1;
  647.          sc_pagelink[ page ] = sc_locklist;
  648.          sc_locklist = page;
  649.              if  (sweep->wordalign.tag == WORDALIGNTAG)  {
  650.                 sweep = (SCP)( ((int*)sweep)+WORDALIGNSIZE );
  651.              }
  652.          sc_lockcnt = (extendedsize( sweep )+PAGEWORDS-1)/PAGEWORDS+
  653.                    sc_lockcnt;
  654. #ifdef GGC
  655.          GGCmarkLocked( sc_locklist, (extendedsize( sweep )+
  656.                          PAGEWORDS-1)/PAGEWORDS );
  657. #endif
  658.           }
  659.           while  (ADDRESS_PAGE( sweep ) == page  &&
  660.               sweep->unsi.gned != ENDOFPAGE)  {
  661.          next = (SCP)( ((int*)sweep)+extendedsize( sweep ) );
  662.          if  ((unsigned)pp < (unsigned)next)  {
  663.             /* sweep points to object to move */
  664.             if  (sc_gcinfo == 2  &&  sweep->forward.tag != FORWARDTAG)
  665.                    fprintf( stderr,
  666.                      "              move_continuation_ptr %x\n",
  667.                     U_TX( sweep ) );
  668.             move_ptr( U_TX( sweep ) );
  669.             return;
  670.          }
  671.          sweep = next;
  672.           }
  673.        }
  674.     }
  675. }
  676.  
  677. /* Objects are moved from old space to new space by calling this procedure
  678.    with a Scheme pointer to the object.  Note that this function does not
  679.    return the new value of the pointer, as it cannot be discerned at this time
  680.    as all locked pages may not have been found yet.  N.B. in the generational
  681.    scheme, only objects in sc_current_generation are moved.
  682. */
  683.  
  684. static  move_ptr( tpp )
  685.     TSCP  tpp;
  686. {
  687.     int  length, words, *oldp, *newp, page;
  688.     TSCP  new;
  689.     SCP  pp;
  690.  
  691.     pp = T_U( tpp );
  692.     switch  TSCPTAG( tpp )  {
  693.  
  694.        case  FIXNUMTAG:
  695.            return;
  696.  
  697.        case  EXTENDEDTAG:
  698.            page = ADDRESS_PAGE( pp );
  699.         if  (page < sc_firstheappage  ||  page > sc_lastheappage  ||
  700.              pp->forward.tag == FORWARDTAG  ||
  701.              pp->wordalign.tag == WORDALIGNTAG  ||
  702.              sc_pagegeneration[ page ] != sc_current_generation)
  703.            return;
  704.         if  (sc_pagetype[ page ] != EXTENDEDTAG)  {
  705.            pointererror( "%x not in an EXTENDEDTAG page\n", pp );
  706.            return;
  707.         }
  708.         words = extendedsize( pp );
  709.         length = words;
  710.         newp = (int*)sc_allocateheap( extendedsize( pp ),
  711.                           pp->extendedobj.tag, 0 );
  712.         new = U_T( newp, EXTENDEDTAG );
  713.         oldp = (int*)pp;
  714.         while  (words--)  *newp++ = *oldp++;
  715.         pp->forward.tag = FORWARDTAG;
  716.         pp->forward.length = length;
  717.         pp->forward.forward = new;
  718.         return;
  719.  
  720.        case  IMMEDIATETAG:
  721.             return;
  722.  
  723.        case  PAIRTAG:
  724.         page = ADDRESS_PAGE( pp );
  725.             if  (pp->forward.tag == FORWARDTAG  ||
  726.              sc_pagegeneration[ page ] != sc_current_generation)
  727.            return;
  728.         if  (sc_pagetype[ page ] != PAIRTAG)  {
  729.            pointererror( "%x not in a PAIRTAG page\n", pp );
  730.            return;
  731.         }
  732.         pp->forward.forward = sc_cons( pp->pair.car, pp->pair.cdr );
  733.         pp->forward.tag = FORWARDTAG;
  734.         pp->forward.length = CONSSIZE;
  735.         return;
  736.     }
  737. }  
  738.  
  739. /* MOVE_OBJECT is called to move all extended objects in a page starting at
  740.    a starting point.  It will return a pointer to the first object that it
  741.    could not move, or NULL if the page was finished.
  742. */
  743.  
  744. static SCP  move_object( pp )
  745.     SCP  pp;
  746. {
  747.     int  page, size, cnt, vpage;
  748.     PATSCP  obj;
  749.  
  750.     page = ADDRESS_PAGE( pp );
  751.     while  (ADDRESS_PAGE( pp ) == page  &&
  752.         (pp != sc_extobjp  ||  sc_extobjwords == 0)  &&
  753.         pp->unsi.gned != ENDOFPAGE)  {
  754.        moving_object = pp;
  755.        switch  ( pp->extendedobj.tag )  {
  756.           case  SYMBOLTAG:
  757.              move_ptr( pp->symbol.name );
  758.          vpage = ADDRESS_PAGE( pp->symbol.ptrtovalue );
  759.          if  (vpage >= sc_firstheappage  &&  vpage <= sc_lastheappage)
  760.             pp->symbol.ptrtovalue = &pp->symbol.value;
  761.          move_ptr( *pp->symbol.ptrtovalue );
  762.          move_ptr( pp->symbol.propertylist );
  763.          size = SYMBOLSIZE;
  764.          break;
  765.  
  766.           case  STRINGTAG:
  767.             size = STRINGSIZE( pp->string.length );
  768.          break;
  769.  
  770.           case  VECTORTAG:
  771.              cnt = pp->vector.length;
  772.          obj = &pp->vector.element0;
  773.          while  (cnt--)  move_ptr( *obj++ );
  774.          size = VECTORSIZE( pp->vector.length );
  775.          break;             
  776.  
  777.           case  PROCEDURETAG:
  778.              move_ptr( pp->procedure.closure );
  779.             size = PROCEDURESIZE;
  780.          break;
  781.  
  782.           case  CLOSURETAG:
  783.              move_ptr( pp->closure.closure );
  784.          cnt = pp->closure.length;
  785.          obj = &pp->closure.var0;
  786.          while  (cnt--)  move_ptr( *obj++ );
  787.          size = CLOSURESIZE( pp->closure.length );
  788.          break;
  789.  
  790.           case  CONTINUATIONTAG:
  791.             move_ptr( pp->continuation.continuation );
  792.          obj = &pp->continuation.continuation;
  793.          cnt = pp->continuation.length;
  794.          while  (cnt--)  move_continuation_ptr( *(++obj) );
  795.          size = CONTINUATIONSIZE( pp->continuation.length );
  796.          break;
  797.  
  798.           case  FLOAT32TAG:
  799.             size = FLOAT32SIZE;
  800.          break;
  801.  
  802.           case  FLOAT64TAG:
  803.             size = FLOAT64SIZE;
  804.          break;
  805.  
  806.           case  FORWARDTAG:
  807.              size = FORWARDSIZE( pp->forward.length );
  808.          break;
  809.  
  810.           case  WORDALIGNTAG:
  811.          size = WORDALIGNSIZE;
  812.          break;
  813.  
  814.           default:
  815.              pointererror( "%x is not a valid extended object tag\n",
  816.                         pp->extendedobj.tag );
  817.        }
  818.        pp = (SCP)( ((int*)pp)+size );
  819.     }
  820.     if  (ADDRESS_PAGE( pp ) == page  &&  pp == sc_extobjp  &&
  821.          sc_extobjwords != 0)
  822.        return( pp );
  823.     return( NULL );
  824. }
  825.  
  826. /* The following function is called to resolve a pointer that might be
  827.    forwarded.  It returns the resolved pointer.
  828. */
  829.  
  830. static TSCP  resolveptr( obj )
  831.     TSCP  obj;
  832. {
  833.     if  ((TSCPTAG( obj ) & 1) && (T_U( obj )->forward.tag == FORWARDTAG))
  834.        return( T_U( obj )->forward.forward );
  835.     return( obj );
  836. }
  837.  
  838. /* Once all objects are moved, objects needing special action on deletion are
  839.    discovered by examining SC_WHENFREED.  All objects that have not been moved
  840.    are placed on SC_FREED, and those that have been moved are retained on
  841.    SC_WHENFREED.
  842. */
  843.  
  844. static  check_unreferenced()
  845. {
  846.     TSCP  objects, object_procedure, object;
  847.  
  848.     objects = resolveptr( sc_whenfreed );
  849.     sc_whenfreed = EMPTYLIST;
  850.     while  (objects != EMPTYLIST)  {
  851.        object_procedure = resolveptr( PAIR_CAR( objects ) );
  852.        object = PAIR_CAR( object_procedure );
  853.        if  (object == resolveptr( object )  &&
  854.         sc_pagegeneration[ ADDRESS_PAGE( object ) ] == 
  855.         sc_current_generation)  {
  856.           /* Object was not forwarded, so it needs to be cleaned up. */
  857.           sc_freed = sc_cons( object_procedure, sc_freed );
  858.        }
  859.        else  {
  860.           /* Object was forwarded, so leave it on sc_whenfreed. */
  861.           sc_whenfreed = sc_cons( object_procedure, sc_whenfreed );
  862.        }
  863.        objects = resolveptr( PAIR_CDR( objects ) );
  864.     }
  865. }
  866.  
  867. /* The moves are coordinated by the following function which moves objects on
  868.    newly allocated pages until there is nothing left to move.
  869. */
  870.  
  871. static  move_the_heap( startpage )
  872.     int  startpage;
  873. {
  874.     int  progress, consstart, extstart, count, unreferenced;
  875.     SCP  myconsp, myextobjp, newp;
  876.  
  877.     myconsp = NULL;
  878.     consstart = startpage;
  879.     myextobjp = NULL;
  880.     extstart = startpage;
  881.     unreferenced = 1;
  882.     progress = 1;
  883.     while  (progress--)  {
  884.        /* Move all the currently allocated, but unmoved pairs. */
  885.        while  (myconsp == NULL  &&  consstart != sc_freepage)  {
  886.           if  (sc_pagegeneration[ consstart ] == sc_next_generation  &&
  887.                sc_pagetype[ consstart ] == PAIRTAG)
  888.              myconsp = (SCP)PAGE_ADDRESS( consstart );
  889.           consstart = NEXTPAGE( consstart );
  890.        }
  891.        if  (myconsp != NULL  &&
  892.            (myconsp != sc_consp || sc_conscnt == 0))  {
  893.           count = (PAGEBYTES-ADDRESS_OFFSET( myconsp ))/CONSBYTES;
  894.           progress = 1;
  895.           while  (count--  &&  (myconsp != sc_consp || sc_conscnt == 0))  {
  896.              moving_object = myconsp;
  897.              move_ptr( myconsp->pair.car );
  898.              move_ptr( myconsp->pair.cdr );
  899.              myconsp = (SCP)(((char*)myconsp)+CONSBYTES);
  900.           }
  901.           if  (count == -1)  myconsp = NULL;
  902.        }
  903.  
  904.        /* Move all currently allocated, but unmoved extended items */
  905.        while  (myextobjp == NULL  &&  extstart != sc_freepage)  {
  906.           if  (sc_pagegeneration[ extstart ] == sc_next_generation  &&
  907.                sc_pagetype[ extstart ] == EXTENDEDTAG)
  908.              myextobjp = (SCP)PAGE_ADDRESS( extstart );
  909.           extstart = NEXTPAGE( extstart );
  910.        }
  911.        if  (myextobjp != NULL)  {
  912.           newp = move_object( myextobjp );
  913.           if  (newp != myextobjp)  progress = 1;
  914.           myextobjp = newp;
  915.        }
  916.        /* Find unreferenced objects needing cleanup */
  917.        if  (progress == 0  &&  unreferenced)  {
  918.           unreferenced = 0;
  919.           check_unreferenced();
  920.           progress = 1;
  921.        }
  922.     }
  923.     if  (pointer_errors)  abort();
  924. }
  925.  
  926. /* Objects in the current generation that have references in previous
  927.    generations are moved in the following routine.
  928. */
  929.  
  930. static  move_the_generations()
  931. {
  932.     int  page = sc_genlist, count;
  933.     SCP  myconsp;
  934.  
  935.     /* Correct the newly allocated pages */
  936.     while  (page != -1)  {
  937.        switch  (sc_pagetype[ page ])  {
  938.  
  939.           case  PAIRTAG:
  940.          myconsp = (SCP)PAGE_ADDRESS( page );
  941.          count = PAGEBYTES/CONSBYTES;
  942.          while  (count--)  {
  943.             move_ptr( myconsp->pair.car );
  944.             move_ptr( myconsp->pair.cdr );
  945.             myconsp = (SCP)(((char*)myconsp)+CONSBYTES);
  946.          }
  947.          break;
  948.  
  949.           case  EXTENDEDTAG:
  950.              move_object( (SCP)PAGE_ADDRESS( page ) );
  951.          break;
  952.        }
  953.        page = sc_pagelink[ page ];
  954.     }
  955. }
  956.  
  957. /* Once all objects are moved, pointers can be corrected to either point to the
  958.    new object (when it can be copied), or point to the old object (when the
  959.    page is locked).  This is done by the following function which takes a
  960.    tagged pointer as its argument and returns the new value of the pointer.
  961. */
  962.  
  963. static TSCP  correct( tobj )
  964.     TSCP  tobj;
  965. {
  966.     SCP  obj;
  967.  
  968.     if  (((int)tobj) & 1)  {
  969.        obj = T_U( tobj );
  970.        if  ( (obj->forward.tag != FORWARDTAG)  ||
  971.              sc_pagelock[ ADDRESS_PAGE( obj ) ] )  return  tobj;
  972.        return( obj->forward.forward );
  973.     }
  974.     return( tobj );
  975. }
  976.  
  977. /* The pointers within extended objects are corrected by the following
  978.    function.  It is called with a pointer to an object.  All objects which
  979.    follow it on that page will be corrected.
  980. */
  981.  
  982. static  correct_object( pp )
  983.     SCP  pp;
  984. {
  985.     int  page, size, cnt;
  986.     PATSCP  obj;
  987.  
  988.     page = ADDRESS_PAGE( pp );
  989.     while  (ADDRESS_PAGE( pp ) == page  &&
  990.         pp->unsi.gned != ENDOFPAGE  &&
  991.         (pp != sc_extobjp  ||  sc_extobjwords == 0))  {
  992.        switch  ( pp->extendedobj.tag )  {
  993.           case  SYMBOLTAG:
  994.              pp->symbol.name = correct( pp->symbol.name );
  995.          *pp->symbol.ptrtovalue = correct( *pp->symbol.ptrtovalue );
  996.          pp->symbol.propertylist = correct( pp->symbol.propertylist );
  997.          size = SYMBOLSIZE;
  998.          break;
  999.  
  1000.           case  STRINGTAG:
  1001.             size = STRINGSIZE( pp->string.length );
  1002.          break;
  1003.  
  1004.           case  VECTORTAG:
  1005.              cnt = pp->vector.length;
  1006.          obj = &pp->vector.element0;
  1007.          while  (cnt--)  {
  1008.             *obj = correct( *obj );
  1009.             obj++;
  1010.          }
  1011.          size = VECTORSIZE( pp->vector.length );
  1012.          break;             
  1013.  
  1014.           case  PROCEDURETAG:
  1015.              pp->procedure.closure = correct( pp->procedure.closure );
  1016.             size = PROCEDURESIZE;
  1017.          break;
  1018.  
  1019.           case  CLOSURETAG:
  1020.              pp->closure.closure = correct( pp->closure.closure );
  1021.          cnt = pp->closure.length;
  1022.          obj = &pp->closure.var0;
  1023.          while  (cnt--)  {
  1024.             *obj = correct( *obj );
  1025.             obj++;
  1026.          }
  1027.          size = CLOSURESIZE( pp->closure.length );
  1028.          break;
  1029.  
  1030.           case  CONTINUATIONTAG:
  1031.             pp->continuation.continuation = 
  1032.             correct( pp->continuation.continuation );
  1033.          size = CONTINUATIONSIZE( pp->continuation.length );
  1034.          break;
  1035.  
  1036.           case  FLOAT32TAG:
  1037.             size = FLOAT32SIZE;
  1038.          break;
  1039.  
  1040.           case  FLOAT64TAG:
  1041.             size = FLOAT64SIZE;
  1042.          break;
  1043.  
  1044.           case  WORDALIGNTAG:
  1045.          size = WORDALIGNSIZE;
  1046.          break;
  1047.  
  1048.           default:
  1049.              fprintf( stderr,
  1050.                         "***** COLLECT Unknown extended object: %x %x\n",
  1051.                         pp, pp->extendedobj.tag );
  1052.              abort();
  1053.        }
  1054.        pp = (SCP)( ((int*)pp)+size );
  1055.     }
  1056. }
  1057.  
  1058. /* Pointer correction is driven by the following function which corrects all
  1059.    pointers in the newly allocated storage.
  1060. */
  1061.  
  1062. static  correct_all_pointers( startpage )
  1063.     int  startpage;
  1064. {
  1065.     int  count;
  1066.     PATSCP  ptr;
  1067.  
  1068.     /* Correct the newly allocated pages */
  1069.     while  (startpage != sc_freepage)  {
  1070.        if  (sc_pagegeneration[ startpage ] == sc_next_generation)  {
  1071.           switch  (sc_pagetype[ startpage ])  {
  1072.  
  1073.          case  PAIRTAG:
  1074.             ptr = (PATSCP)PAGE_ADDRESS( startpage );
  1075.             count = PAGEBYTES/(CONSBYTES/2);
  1076.             while  (count--  &&
  1077.                     (sc_consp != (SCP)ptr  ||  sc_conscnt == 0))  {
  1078.                if  ((*((int*)ptr) & 1)  &&
  1079.                     (T_U(*ptr)->forward.tag == FORWARDTAG)  &&
  1080.                     (sc_pagelock[ ADDRESS_PAGE( *ptr ) ] == 0))
  1081.                   *ptr = T_U(*ptr)->forward.forward;
  1082.                ptr++;
  1083.             }
  1084.             break;
  1085.  
  1086.          case  EXTENDEDTAG:
  1087.             correct_object( (SCP)PAGE_ADDRESS( startpage ) );
  1088.             break;
  1089.           }
  1090.        }
  1091.        startpage = NEXTPAGE( startpage );
  1092.     }
  1093. }
  1094. /* Pointer correction to newly allocated storage in previous generations is
  1095.    done by the following procedure.
  1096. */
  1097.  
  1098. static  correct_all_generations()
  1099. {
  1100.     int  page = sc_genlist, count, i;
  1101.     PATSCP  ptr;
  1102.  
  1103.     /* Correct the newly allocated pages */
  1104.     while  (page != -1)  {
  1105.        switch  (sc_pagetype[ page ])  {
  1106.           case  PAIRTAG:
  1107.          ptr = (PATSCP)PAGE_ADDRESS( page );
  1108.          count = PAGEBYTES/(CONSBYTES/2);
  1109.          while  (count--)  {
  1110.             if  ((*((int*)ptr) & 1)  &&
  1111.                  (T_U(*ptr)->forward.tag == FORWARDTAG)  &&
  1112.                  (sc_pagelock[ ADDRESS_PAGE( *ptr ) ] == 0))
  1113.                *ptr = T_U(*ptr)->forward.forward;
  1114.             ptr++;
  1115.             }
  1116.          i = page;
  1117.          page = sc_pagelink[ page ];
  1118.          sc_pagelink[ i ] = 0;
  1119.          break;
  1120.  
  1121.            case  EXTENDEDTAG:
  1122.          correct_object( (SCP)PAGE_ADDRESS( page ) );
  1123.          i = page;
  1124.          page = sc_pagelink[ page ];
  1125.          do  sc_pagelink[ i++ ] = 0;
  1126.          while  (i <= sc_lastheappage  &&
  1127.              sc_pagetype[ i ] == BIGEXTENDEDTAG);
  1128.          break;
  1129.        }
  1130.     }
  1131. }
  1132.  
  1133. /* After pointers have been corrected, the items on locked pages need to have
  1134.    their correct version (found in the new copy) copied to the old page.  In
  1135.    addition, objects which were not forwarded must be changed so that their
  1136.    pointers will no longer be followed.  This is done by setting the CAR and
  1137.    CDR of the pair to 0, and turning extended objects into strings.  Pages
  1138.    that are locked are added to sc_genlist so that will be checked on the
  1139.    next collection.
  1140. */
  1141.  
  1142. static  copyback_locked_pages( locklist )
  1143.     int  locklist;
  1144. {
  1145.     int  page, count, vpage;
  1146.     SCP  obj, fobj, sobj;
  1147.  
  1148.     while  (locklist)  {
  1149.        page = locklist;
  1150. #ifdef GGC
  1151.        GGCmarkUnlock( page );
  1152. #endif
  1153.        obj = (SCP)PAGE_ADDRESS( page );
  1154.        sc_pagelock[ page ] = 0;
  1155.        sc_pagegeneration[ page ] = sc_next_generation;
  1156.        locklist = sc_pagelink[ locklist ];
  1157.        sc_pagelink[ page ] = sc_genlist;
  1158.        sc_genlist = page;
  1159.        if  (sc_pagetype[ page ] == PAIRTAG)  {
  1160.           /* Move back only the forwarded CONS cells */
  1161.           count = PAGEBYTES/CONSBYTES;
  1162.           while  (count--)  {
  1163.              if  (obj->forward.tag == FORWARDTAG)  {
  1164.             fobj = T_U( obj->forward.forward );
  1165.             obj->pair.car = fobj->pair.car;
  1166.             obj->pair.cdr = fobj->pair.cdr;
  1167.          }
  1168.          else  {
  1169.             obj->pair.car = 0;
  1170.             obj->pair.cdr = 0;
  1171.          }
  1172.          obj = (SCP)((char*)(obj)+CONSBYTES);
  1173.           }
  1174.        }
  1175.        else  if  (sc_pagetype[ page ] == EXTENDEDTAG)  {
  1176.           /* Move extra pages into the next generation */
  1177.           if  (obj->wordalign.tag == WORDALIGNTAG)  {
  1178.          obj = (SCP)( ((int*)obj)+WORDALIGNSIZE );
  1179.           }
  1180.           count = extendedsize( obj );
  1181.           vpage = page;
  1182.           while (count > PAGEWORDS)  {
  1183.          sc_pagegeneration[ ++vpage ] = sc_next_generation;
  1184.          sc_pagelink[ vpage ] = OKTOSET;
  1185.          count = count-PAGEWORDS;
  1186. #ifdef GGC
  1187.          GGCmarkUnlock( vpage );
  1188. #endif
  1189.           }
  1190.           /* Move back the forwarded extended items */
  1191.           while  (ADDRESS_PAGE( obj ) == page  &&
  1192.                     (obj != sc_extobjp  ||  sc_extobjwords == 0)  &&
  1193.                     obj->unsi.gned != ENDOFPAGE)  {
  1194.          if  (obj->forward.tag == FORWARDTAG)  {
  1195.             sobj = obj;
  1196.             fobj = T_U( obj->forward.forward );
  1197.             count = obj->forward.length;
  1198.             while  (count--)  {
  1199.                *((int*)obj) = *((int*)fobj);
  1200.                obj = (SCP)(((int*)obj)+1);
  1201.                fobj = (SCP)(((int*)fobj)+1);
  1202.             }
  1203.             if  (sobj->symbol.tag == SYMBOLTAG)  {
  1204.                vpage = ADDRESS_PAGE( sobj->symbol.ptrtovalue );
  1205.                if  (vpage >= sc_firstheappage  &&
  1206.                     vpage <= sc_lastheappage)
  1207.                   sobj->symbol.ptrtovalue = &sobj->symbol.value;
  1208.             }
  1209.          }
  1210.          else  if  (obj->wordalign.tag == WORDALIGNTAG)  {
  1211.             obj = (SCP)( ((int*)obj)+WORDALIGNSIZE );
  1212.          }
  1213.          else  {
  1214.             count = extendedsize( obj );
  1215.             obj->string.length = ((count-2)*4)+3;
  1216.             obj->string.tag = STRINGTAG;
  1217.             obj = (SCP)( ((int*)obj)+count );
  1218.          }
  1219.           }
  1220.        }
  1221.     }
  1222. }       
  1223.  
  1224. /* This function is called to check the obarray to make sure that it is
  1225.    intact.
  1226. */
  1227.  
  1228. static int check_obarray()
  1229. {
  1230.     int  i, len, page;
  1231.     PATSCP  ep;
  1232.     TSCP  lp, symbol, value;
  1233.     SCP  obarray;
  1234.  
  1235.     obarray = T_U( sc_obarray );
  1236.     if  (TSCPTAG( sc_obarray ) != EXTENDEDTAG  ||
  1237.          obarray->vector.tag != VECTORTAG)  {
  1238.        fprintf( stderr, "***** COLLECT OBARRAY is not a vector %x\n",
  1239.                 sc_obarray );
  1240.        abort();
  1241.     }
  1242.     len = obarray->vector.length;
  1243.     if  (len != 1023)   {
  1244.        fprintf( stderr, "***** COLLECT OBARRAY length is wrong %x\n",
  1245.                sc_obarray );
  1246.        abort();
  1247.     }
  1248.     ep = &obarray->vector.element0;
  1249.     for  (i = 0;  i < len;  i++)  {
  1250.        lp = *ep++;
  1251.        while  (lp != EMPTYLIST)  {
  1252.           if  (TSCPTAG( lp ) != PAIRTAG)  {
  1253.              fprintf( stderr,
  1254.                "***** COLLECT OBARRAY element is not a list %x\n",
  1255.               lp );
  1256.          abort();
  1257.           }
  1258.           symbol = T_U( lp )->pair.car;
  1259.           if  (T_U( symbol )->symbol.tag != SYMBOLTAG)  {
  1260.              fprintf( stderr,
  1261.                "***** COLLECT OBARRAY entry is not a symbol %x\n",
  1262.               symbol );
  1263.              abort();
  1264.           }
  1265.           page = ADDRESS_PAGE( symbol );
  1266.           if  (sc_pagegeneration[ page ] & 1  &&
  1267.                sc_pagegeneration[ page ] != sc_current_generation)  {
  1268.              fprintf( stderr,
  1269.                "***** COLLECT OBARRAY symbol generation error %x\n",
  1270.               symbol );
  1271.              abort();
  1272.           }
  1273.           value = *T_U( symbol )->symbol.ptrtovalue;
  1274.           page = ADDRESS_PAGE( value );
  1275.           if  (TSCPTAG( value ) & 1  &&
  1276.            page >= sc_firstheappage  &&  page <= sc_lastheappage  &&
  1277.                  sc_pagegeneration[ page ] & 1  &&
  1278.            sc_pagegeneration[ page ] != sc_current_generation)  {
  1279.              fprintf( stderr,
  1280.                "***** COLLECT OBARRAY value generation error %x\n",
  1281.               symbol );
  1282.              abort();
  1283.           }
  1284.           if  (TSCPTAG( value ) & 1  &&
  1285.            (~sc_pagegeneration[ ADDRESS_PAGE( symbol ) ]) & 1  &&
  1286.            sc_pagegeneration[ page ] == sc_current_generation  &&
  1287.            sc_pagelink[ ADDRESS_PAGE( symbol ) ] == 0  &&
  1288.            ADDRESS_PAGE( symbol ) == 
  1289.            ADDRESS_PAGE( T_U( symbol )->symbol.ptrtovalue ))  {
  1290.          fprintf( stderr,
  1291.                "***** COLLECT OBARRAY missed a top-level set! %x\n",
  1292.               symbol );
  1293.          abort();
  1294.           }
  1295.           if  (sc_pagetype[ ADDRESS_PAGE( symbol ) ] != EXTENDEDTAG)  {
  1296.              fprintf( stderr,
  1297.                   "***** COLLECT OBARRAY symbol page type error %x\n",
  1298.               symbol );
  1299.              abort();
  1300.           }
  1301.           lp = T_U( lp )->pair.cdr;
  1302.        }
  1303.     }
  1304. }
  1305.  
  1306. /* The following procedure verifies that a pointer is correct. */
  1307.  
  1308. static  check_ptr( tpp )
  1309.     TSCP  tpp;
  1310. {
  1311.     int  page;
  1312.  
  1313.     page = ADDRESS_PAGE( tpp );
  1314.     if  (page >= sc_firstheappage  &&  page <= sc_lastheappage  &&
  1315.          ((int) tpp) & 1)  {
  1316.        if  ((sc_pagegeneration[ page ] != sc_current_generation  &&
  1317.               sc_pagegeneration[ page ] & 1)  ||
  1318.         sc_pagetype[ page ] != TSCPTAG( tpp ))  {
  1319.           pointererror( "%x fails check_ptr\n", T_U( tpp ) );
  1320.        }
  1321.     }
  1322.     else  if  (TSCPTAG( tpp ) == PAIRTAG)  {
  1323.        pointererror( "%x fails check_ptr\n", T_U( tpp ) );
  1324.     }
  1325. }
  1326.  
  1327. /* A page of objects is checked by the following procedure. */
  1328.  
  1329. static SCP  check_object( pp )
  1330.     SCP  pp;
  1331. {
  1332.     int  page, size, cnt, vpage;
  1333.     PATSCP  obj;
  1334.  
  1335.     page = ADDRESS_PAGE( pp );
  1336.     while  (ADDRESS_PAGE( pp ) == page  &&
  1337.         (pp != sc_extobjp  ||  sc_extobjwords == 0)  &&
  1338.         pp->unsi.gned != ENDOFPAGE)  {
  1339.        moving_object = pp;
  1340.        switch  ( pp->extendedobj.tag )  {
  1341.           case  SYMBOLTAG:
  1342.              check_ptr( pp->symbol.name );
  1343.          vpage = ADDRESS_PAGE( pp->symbol.ptrtovalue );
  1344.          if  (vpage >= sc_firstheappage  &&  vpage <= sc_lastheappage)
  1345.             pp->symbol.ptrtovalue = &pp->symbol.value;
  1346.          check_ptr( *pp->symbol.ptrtovalue );
  1347.          check_ptr( pp->symbol.propertylist );
  1348.          size = SYMBOLSIZE;
  1349.          break;
  1350.  
  1351.           case  STRINGTAG:
  1352.             size = STRINGSIZE( pp->string.length );
  1353.          break;
  1354.  
  1355.           case  VECTORTAG:
  1356.              cnt = pp->vector.length;
  1357.          obj = &pp->vector.element0;
  1358.          while  (cnt--)  check_ptr( *obj++ );
  1359.          size = VECTORSIZE( pp->vector.length );
  1360.          break;             
  1361.  
  1362.           case  PROCEDURETAG:
  1363.              check_ptr( pp->procedure.closure );
  1364.             size = PROCEDURESIZE;
  1365.          break;
  1366.  
  1367.           case  CLOSURETAG:
  1368.              check_ptr( pp->closure.closure );
  1369.          cnt = pp->closure.length;
  1370.          obj = &pp->closure.var0;
  1371.          while  (cnt--)  check_ptr( *obj++ );
  1372.          size = CLOSURESIZE( pp->closure.length );
  1373.          break;
  1374.  
  1375.           case  CONTINUATIONTAG:
  1376.             check_ptr( pp->continuation.continuation );
  1377.          size = CONTINUATIONSIZE( pp->continuation.length );
  1378.          break;
  1379.  
  1380.           case  FLOAT32TAG:
  1381.             size = FLOAT32SIZE;
  1382.          break;
  1383.  
  1384.           case  FLOAT64TAG:
  1385.             size = FLOAT64SIZE;
  1386.          break;
  1387.  
  1388.           case  FORWARDTAG:
  1389.              size = FORWARDSIZE( pp->forward.length );
  1390.          break;
  1391.  
  1392.           case  WORDALIGNTAG:
  1393.          size = WORDALIGNSIZE;
  1394.          break;
  1395.  
  1396.           default:
  1397.              pointererror( "%x is not a valid extended object tag\n",
  1398.                         pp->extendedobj.tag );
  1399.        }
  1400.        pp = (SCP)( ((int*)pp)+size );
  1401.     }
  1402.     if  (ADDRESS_PAGE( pp ) == page  &&  pp == sc_extobjp  &&
  1403.          sc_extobjwords != 0)
  1404.        return( pp );
  1405.     return( NULL );
  1406. }
  1407.  
  1408. /* A page of pairs is checkled by the following procedure. */
  1409.  
  1410. static void  check_pairs( pp )
  1411.     SCP  pp;
  1412. {
  1413.     int  count;
  1414.     PATSCP  ptr;
  1415.  
  1416.     ptr = (PATSCP)pp;
  1417.     count = (PAGEBYTES/CONSBYTES)*2;
  1418.     while  (count--  &&
  1419.         (ptr != (PATSCP)sc_consp  ||  sc_conscnt == 0))  {
  1420.        moving_object = (SCP)(((unsigned)ptr) & 0xfffffff8);
  1421.        check_ptr( *ptr );
  1422.        ptr++;
  1423.      }
  1424. }
  1425.  
  1426. /* The following function can be called to check that all objects in the
  1427.    heap are valid.
  1428. */
  1429.  
  1430. static void  check_heap( )
  1431. {
  1432.     int  i;
  1433.  
  1434.     /* Verify that all pages containing pairs are in good shape */
  1435.     for  (i = sc_firstheappage; i <= sc_lastheappage; i++)  {
  1436.        if  ((sc_pagegeneration[ i ] == sc_current_generation  ||
  1437.         ~sc_pagegeneration[ i ] & 1))  {
  1438.           if  (sc_pagetype[ i ] == PAIRTAG)  {
  1439.          check_pairs( (SCP)PAGE_ADDRESS( i ) );
  1440.           }
  1441.           if  (sc_pagetype[ i ] == EXTENDEDTAG)  {
  1442.          check_object( (SCP)PAGE_ADDRESS( i ) );
  1443.           }
  1444.        }
  1445.     }
  1446.     if  (pointer_errors)  abort();
  1447. }
  1448.     
  1449. /* Garbage collection is invoked to attempt to recover free storage when a
  1450.    request for storage cannot be met.  It will recover using a generational
  1451.    version of the "mostly copying" method.  See the .h file or the research
  1452.    report for more details.
  1453. */
  1454.  
  1455. TSCP  sc_collect_v;
  1456.  
  1457. TSCP  sc_collect()
  1458. {
  1459.     int  i, wasallocated, startpage;
  1460.     TSCP  constl;
  1461.  
  1462. #ifdef GGC
  1463.     GGCbeginCollection();
  1464. #endif
  1465.     if  (sc_current_generation != sc_next_generation)  {
  1466.        fprintf( stderr, "***** COLLECT Out of space during collection\n" );
  1467.        abort();
  1468.     }
  1469.     sc_gcinprogress( 1 );
  1470.     sc_initiallink = ~OKTOSET;
  1471.     wasallocated = sc_allocatedheappages;
  1472.  
  1473.     if  (sc_gcinfo == 2)  {
  1474.        /* Perform additional consistency checks */
  1475.        check_obarray();
  1476.        check_heap();
  1477.     }
  1478.     if  (sc_gcinfo)  {
  1479.        fprintf( stderr,
  1480.                "\n***** COLLECT %d%% allocated (%d%% waste) -> \n",
  1481.                (wasallocated*100)/sc_heappages,
  1482.             (sc_extwaste*100)/(sc_heappages*PAGEWORDS) );
  1483.     }
  1484.     getrusage( 0, &startru );
  1485.  
  1486.     /* Zero the current cons block, end the current extended block,
  1487.        initialize sc_locklist, advance the generation.
  1488.     */
  1489.     sc_conscnt = sc_conscnt+sc_conscnt;
  1490.     while  (sc_conscnt-- > 0)  {
  1491.        *((int*)sc_consp) = 0;
  1492.        sc_consp = (SCP)(((int*)sc_consp)+1);
  1493.     }
  1494.     sc_conscnt = 0;
  1495.     if  (sc_extobjwords)  {
  1496.        sc_extobjp->unsi.gned = ENDOFPAGE;
  1497.        sc_extobjwords = 0;
  1498.     }
  1499.     sc_extwaste = 0;
  1500.     sc_allocatedheappages = 0;
  1501.     sc_locklist = 0;
  1502.     sc_lockcnt = 0;
  1503.     sc_next_generation = INC_GENERATION( sc_current_generation );
  1504.     startpage = sc_freepage;
  1505.     
  1506.     /* Move the globals, display, and constants (as needed) */
  1507.     for  ( i = 0; i < sc_globals->count; i++ )  {
  1508.        move_ptr( *(sc_globals->ptrs[ i ]) );
  1509.     }
  1510.     for  ( i = 0; i < sc_maxdisplay; i++ )  move_ptr( sc_display[ i ] );
  1511.     if  (sc_pagegeneration[ ADDRESS_PAGE( *(sc_constants->ptrs[ 0 ]) ) ] ==
  1512.          sc_current_generation)  {
  1513.        for  ( i = 0; i < sc_constants->count; i++ )
  1514.           move_ptr( *(sc_constants->ptrs[ i ]) );
  1515.     }
  1516.  
  1517.     /* Look into the stack and the registers and treat anything that
  1518.        might be a pointer as a root and move it.
  1519.     */
  1520.     trace_stack_and_registers();
  1521. #ifdef GGC
  1522.     GGCafterLockingInCollection();
  1523. #endif
  1524.  
  1525.     /* Move new objects referenced in previous generations */
  1526.     move_the_generations();
  1527.  
  1528.     /* Continue the moving the current generation until it terminates */
  1529.     move_the_heap( startpage );
  1530.     sc_allocatedheappages = sc_allocatedheappages+sc_lockcnt;
  1531.  
  1532.     /* Correct pointers in the copied heap */
  1533.     correct_all_pointers( startpage );
  1534.  
  1535.     /* Correct pointers in previous generations */
  1536.     correct_all_generations();
  1537.  
  1538.     /* Correct pointers in globals, display, and constants (if moved) */
  1539.     for  ( i = 0; i < sc_globals->count; i++ )
  1540.        *(sc_globals->ptrs[ i ]) = correct( *(sc_globals->ptrs[ i ]) );
  1541.     for  ( i = 0; i < sc_maxdisplay; i++ )
  1542.        sc_display[ i ] = correct( sc_display[ i ] );
  1543.     if  (sc_pagegeneration[ ADDRESS_PAGE( *(sc_constants->ptrs[ 0 ]) ) ] ==
  1544.          sc_current_generation)  {
  1545.        for  ( i = 0; i < sc_constants->count; i++ )
  1546.           *(sc_constants->ptrs[ i ]) =
  1547.                     correct( *(sc_constants->ptrs[ i ]) );
  1548.     }
  1549.  
  1550.     /* Copy back the locked objects and add locked pages to sc_genlist */
  1551.     sc_genlist = -1;
  1552.     copyback_locked_pages( sc_locklist );
  1553. #ifdef GGC
  1554.     GGCafterUnlockingInCollection();
  1555. #endif
  1556.  
  1557.     /* Fully allocate partial pages and step to the next odd generation */
  1558.     sc_conscnt = sc_conscnt+sc_conscnt;
  1559.     while  (sc_conscnt-- > 0)  {
  1560.        *((int*)sc_consp) = 0;
  1561.        sc_consp = (SCP)(((int*)sc_consp)+1);
  1562.     }
  1563.     sc_conscnt = 0;
  1564.     if  (sc_extobjwords)  {
  1565.        sc_extobjp->unsi.gned = ENDOFPAGE;
  1566.        sc_extobjwords = 0;
  1567.     }
  1568.     sc_next_generation = sc_current_generation = 
  1569.                  INC_GENERATION( sc_next_generation );    
  1570.     sc_generationpages = sc_generationpages+sc_allocatedheappages;
  1571.     sc_allocatedheappages = sc_generationpages;
  1572.  
  1573.     /* Finish up */
  1574.     getrusage( 0, &stopru );
  1575.     updategcru();
  1576.     if  (sc_gcinfo)  { 
  1577. #ifndef NO_RUSAGE
  1578.        fprintf( stderr,
  1579.                 "              %d%% locked  %d%% retained  %d user ms",
  1580.             (sc_lockcnt*100)/sc_heappages,
  1581.                 (sc_generationpages*100)/sc_heappages,
  1582.             stopru.ru_utime.tv_sec*1000+stopru.ru_utime.tv_usec/1000 );
  1583.        fprintf( stderr,
  1584.                "  %d system ms  %d page faults\n",
  1585.             stopru.ru_stime.tv_sec*1000+stopru.ru_stime.tv_usec/1000,
  1586.             stopru.ru_majflt );
  1587. #else
  1588.        fprintf( stderr,
  1589.                 "              %d%% locked  %d%% retained\n",
  1590.             (sc_lockcnt*100)/sc_heappages,
  1591.                 (sc_generationpages*100)/sc_heappages);
  1592. #endif
  1593.     }
  1594.     if  (sc_gcinfo == 2)  {
  1595.        /* Perform additional consistency checks */
  1596.        check_obarray();
  1597.        check_heap();
  1598.     }
  1599. #ifdef GGC
  1600.         for  (i = sc_firstheappage;  i <= sc_lastheappage;  i++)  {
  1601.        if  (sc_pagegeneration[ i ] != sc_current_generation)
  1602.           GGCmarkFree(i);
  1603.         }
  1604.         GGCendCollection();
  1605. #endif
  1606.  
  1607.     /* Compact the whole heap if > sc_limit % of pages allocated */
  1608.     sc_initiallink = OKTOSET;
  1609.     sc_gcinprogress( 0 );
  1610.     if  ((sc_allocatedheappages*100)/sc_heappages > sc_limit)
  1611.        sc_collect_2dall();
  1612.     if  (sc_after_2dcollect_v != FALSEVALUE)
  1613.        sc_apply_2dtwo( sc_after_2dcollect_v,
  1614.             sc_cons( C_FIXED( sc_heappages*PAGEBYTES ),
  1615.               sc_cons( C_FIXED( sc_allocatedheappages*PAGEBYTES ),
  1616.                        sc_cons( C_FIXED( sc_limit ),
  1617.                            EMPTYLIST ) ) ) );
  1618.     return( TRUEVALUE );
  1619. }
  1620.  
  1621. /* A complete garbage collection can be forced by calling the following
  1622.    procedure.
  1623. */
  1624.  
  1625. TSCP  sc_collect_2dall_v;
  1626.  
  1627. TSCP  sc_collect_2dall()
  1628. {
  1629.     int  i,
  1630.          save_sc_limit = sc_limit;
  1631.  
  1632.     MUTEXON;
  1633.     sc_limit = 100;
  1634.     if  (sc_generationpages != sc_allocatedheappages)  sc_collect();
  1635.     sc_limit = save_sc_limit;
  1636.     MUTEXOFF;
  1637.     MUTEXON;
  1638.     sc_next_generation = 
  1639.         INC_GENERATION( INC_GENERATION( sc_next_generation ) );
  1640.     sc_current_generation = sc_next_generation;
  1641.     for  (i = sc_firstheappage; i <= sc_lastheappage; i++)  {
  1642.        if  (~sc_pagegeneration[ i ] & 1)
  1643.           sc_pagegeneration[ i ] = sc_current_generation;
  1644.     }
  1645.      sc_generationpages = 0;
  1646.     sc_genlist = -1;
  1647.     sc_limit = 100;
  1648.     sc_collect();
  1649.     sc_limit = save_sc_limit;
  1650.     MUTEXOFF;
  1651.     return( TRUEVALUE );
  1652. }
  1653.  
  1654. /* Pages in the heap are allocated by the following function.  It is called
  1655.    with a page count and sets the appropriate allocation pointers as
  1656.    required.  The sc_pagegeneration, sc_pagelink, sc_pagetype fields are
  1657.    set for each page here.  The garbage collector is invoked as needed.
  1658. */
  1659.  
  1660. static int  allocatepage_failed = 0;    /* Set following collection, cleared on
  1661.                           successful allocation */
  1662.  
  1663. static  allocatepage( count, tag )
  1664.     int  count, tag;
  1665. {
  1666.     int  start, page, freecnt, generation;
  1667.  
  1668.     if  ((count+sc_allocatedheappages) > sc_heappages/2)  {
  1669. failed:
  1670.        if  (allocatepage_failed)  {
  1671.           fprintf( stderr,
  1672.                "***** ALLOCATEPAGE cannot allocate %d bytes",
  1673.                   count*PAGEBYTES );
  1674.           fprintf( stderr, " with %d %% of heap allocated\n",
  1675.                   (sc_allocatedheappages*100)/sc_heappages );
  1676.        exit( 1 );
  1677.        }
  1678.        sc_collect();
  1679.        allocatepage_failed = 1;
  1680.        return;
  1681.     }
  1682.     start = sc_freepage;
  1683.     freecnt = 0;
  1684.     do  {
  1685.        generation = sc_pagegeneration[ sc_freepage ];
  1686.        if  (generation & 1  &&  generation != sc_current_generation)  {
  1687.           if  (freecnt == 0)  page = sc_freepage;
  1688.           freecnt++;
  1689.        }
  1690.        else
  1691.           freecnt = 0;
  1692.        if  (sc_freepage == sc_lastheappage)  {
  1693.           if  (freecnt != count)  freecnt = 0;
  1694.           sc_freepage = sc_firstheappage;
  1695.        }
  1696.        else  sc_freepage++;
  1697.        if  (sc_freepage == start)  goto failed;
  1698.     }  while  (count != freecnt);
  1699.     allocatepage_failed = 0;
  1700.     sc_allocatedheappages = sc_allocatedheappages+count;
  1701.     sc_pagegeneration[ page ] = sc_next_generation;
  1702.     sc_pagetype[ page ] = tag;
  1703.     sc_pagelink[ page ] = sc_initiallink;
  1704.     if  (tag == PAIRTAG)  {
  1705.        sc_conscnt = PAGEBYTES/CONSBYTES;
  1706.        sc_consp = (SCP)PAGE_ADDRESS( page );
  1707. #ifdef GGC
  1708.        GGCmarkPair( page );
  1709. #endif
  1710.     }
  1711.     else  {
  1712.        sc_extobjp = (SCP)PAGE_ADDRESS( page );
  1713.        sc_extobjwords = count*PAGEWORDS;
  1714. #ifdef GGC
  1715.            GGCmarkExtended( page );
  1716.            GGCmarkContinuations( page+1, count-1 );
  1717. #endif
  1718.        while (--count)  {
  1719.           sc_pagegeneration[ ++page ] = sc_next_generation;
  1720.           sc_pagetype[ page ] = BIGEXTENDEDTAG;
  1721.           sc_pagelink[ page ] = sc_initiallink;
  1722.        }
  1723.     }    
  1724. }
  1725.  
  1726. /* When a pointer to a new object may be stored in a old page, the following
  1727.    procedure is called to add the old page to the list of changed older pages
  1728.    and then do the assignment.  N.B.  set-top-level-value! may set global
  1729.    values outside the heap.
  1730. */
  1731.  
  1732. TSCP  sc_setgeneration( a, b )
  1733.     TSCP* a;
  1734.     TSCP  b;
  1735. {
  1736.     int  oldpage = ADDRESS_PAGE( a );
  1737.  
  1738.     MUTEXON;
  1739.     if  (oldpage >= sc_firstheappage  &&  oldpage <= sc_lastheappage  &&
  1740.          sc_pagelink[ oldpage ] == 0)  {
  1741.        if  (sc_pagetype[ oldpage ] == PAIRTAG)  {
  1742.           if  (sc_pagegeneration[ oldpage ] == sc_current_generation)  {
  1743.              sc_pagelink[ oldpage ] = OKTOSET;
  1744.           }
  1745.           else  {
  1746.              sc_pagelink[ oldpage ] = sc_genlist;
  1747.              sc_genlist = oldpage;
  1748.           }
  1749.        }
  1750.        else  {
  1751.           while  (sc_pagetype[ oldpage ] == BIGEXTENDEDTAG)  oldpage--;
  1752.           if  (sc_pagegeneration[ oldpage ] == sc_current_generation)  {
  1753.              sc_pagelink[ oldpage ] = OKTOSET;
  1754.           }
  1755.           else  {
  1756.              sc_pagelink[ oldpage ] = sc_genlist;
  1757.              sc_genlist = oldpage;
  1758.           }
  1759.           while  (++oldpage < sc_lastheappage  &&  
  1760.               sc_pagetype[ oldpage ] == BIGEXTENDEDTAG)  {
  1761.              sc_pagelink[ oldpage ] = OKTOSET;
  1762.           }
  1763.        }
  1764.     }
  1765.     *a = b;
  1766.     MUTEXOFF;
  1767.     return( b );
  1768. }
  1769.     
  1770. /* Heap based storage is allocated by the following function.  It is called
  1771.    with a word count and a value to put in the first word.  It will return
  1772.    an UNTAGGED pointer to the storage.  Note that the minimum permissible
  1773.    allocation size is two words.
  1774.  
  1775.    N.B.  IT IS THE CALLER'S RESPONSIBILITY TO ASSURE THAT SIGNALS DO NOT
  1776.      CAUSE PROBLEMS DURING ALLOCATION.
  1777. */
  1778.  
  1779. SCP  sc_allocateheap( wordsize, tag, rest )
  1780.     int  wordsize, tag, rest;
  1781. {
  1782.     SCP  alloc;
  1783.     int  isastring = (tag == STRINGTAG);
  1784.  
  1785.     EVEN_EXTOBJP( tag == FLOAT64TAG );
  1786.     ODD_EXTOBJP( isastring );
  1787.     if  (wordsize <= sc_extobjwords)  {
  1788.        alloc = sc_extobjp;
  1789.        sc_extobjp = (SCP)(((int*)alloc)+wordsize);
  1790.        sc_extobjwords = sc_extobjwords-wordsize;
  1791.     }
  1792.     else  if  (wordsize < PAGEWORDS)  {
  1793.        while  (wordsize > sc_extobjwords)  {
  1794.           sc_extwaste = sc_extwaste+sc_extobjwords;
  1795.           if  (sc_extobjwords)  sc_extobjp->unsi.gned = ENDOFPAGE;
  1796.           allocatepage( 1, EXTENDEDTAG );
  1797.           EVEN_EXTOBJP( tag == FLOAT64TAG );
  1798.           ODD_EXTOBJP( isastring );
  1799.        }
  1800.        alloc = sc_extobjp;
  1801.        sc_extobjwords = sc_extobjwords-wordsize;
  1802.        sc_extobjp = (SCP)(((int*)alloc)+wordsize);
  1803.     }
  1804.     else  {
  1805.        while  (wordsize > sc_extobjwords)  {
  1806.           sc_extwaste = sc_extwaste+sc_extobjwords;
  1807.           if  (sc_extobjwords)  sc_extobjp->unsi.gned = ENDOFPAGE;
  1808.           allocatepage( (wordsize+PAGEWORDS-1+isastring)/PAGEWORDS,
  1809.                       EXTENDEDTAG );
  1810.        }
  1811.        ODD_EXTOBJP( isastring );
  1812.        alloc = sc_extobjp;
  1813.        sc_extobjp = NULL;
  1814.        sc_extobjwords = 0;
  1815.     }
  1816.     alloc->extendedobj.tag = tag;
  1817.     alloc->extendedobj.rest = rest;
  1818.     return( alloc );
  1819. }
  1820.  
  1821. /* 32-bit floating point numbers are constructed by the following function.  It
  1822.    is called with a 32-bit floating point value and it returns a pointer to
  1823.    the Scheme object with that value.
  1824. */
  1825.  
  1826. #ifdef PRISM
  1827. TSCP sc_makefloat32( float value )
  1828. #else
  1829. TSCP sc_makefloat32( value )
  1830.     float  value;
  1831. #endif
  1832. {
  1833.     SCP  pp;
  1834.  
  1835.     MUTEXON;
  1836.     if  (sc_extobjwords >= FLOAT32SIZE)  {
  1837.        pp = sc_extobjp;
  1838.        sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE);
  1839.        sc_extobjwords = sc_extobjwords-FLOAT32SIZE;
  1840.        pp->float32.tag = FLOAT32TAG;
  1841.        pp->float32.rest = 0;
  1842.     }
  1843.     else
  1844.        pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 );
  1845.     pp->float32.value = value;
  1846.     MUTEXOFF;
  1847.     return( U_T( pp, EXTENDEDTAG ) );
  1848. }
  1849.  
  1850. /* 64-bit floating point numbers are constructed by the following function.  It
  1851.    is called with a 64-bit floating point value and it returns a pointer to
  1852.    the Scheme object with that value.
  1853.  
  1854.    On the Apollo Prism, it is vital that we use a function prototype,
  1855.    so the compiler knows that the function's argument is being passed
  1856.    in a register.  Without the prototype, the argument is read from
  1857.    the stack.  See prism.asm for examples where it is simpler to pass
  1858.    the argument in a register.  Also see objects.h for the declaration.
  1859. */
  1860.  
  1861. #ifdef PRISM
  1862. TSCP sc_makefloat64( double value )
  1863. #else
  1864. TSCP sc_makefloat64( value )
  1865.     double  value;
  1866. #endif
  1867. {
  1868.     SCP  pp;
  1869.  
  1870.     MUTEXON;
  1871.     EVEN_EXTOBJP( 1 );
  1872.     if  (sc_extobjwords >= FLOAT64SIZE)  {
  1873.        pp = sc_extobjp;
  1874.        sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE);
  1875.        sc_extobjwords = sc_extobjwords-FLOAT64SIZE;
  1876.        pp->float64.tag = FLOAT64TAG;
  1877.        pp->float64.rest = 0;
  1878.     }
  1879.     else
  1880.        pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 );
  1881.     pp->float64.value = value;
  1882.     MUTEXOFF;
  1883.     return( U_T( pp, EXTENDEDTAG ) );
  1884. }
  1885.  
  1886. /* The following function forms a dotted-pair with any two Scheme pointers.  It
  1887.    returns a tagged pointer to the pair as its value.
  1888. */
  1889.  
  1890. TSCP  sc_cons_v;
  1891.  
  1892. TSCP  sc_cons( x, y )
  1893.     TSCP x, y;
  1894. {
  1895.     SCP  oconsp;
  1896.  
  1897.     MUTEXON;
  1898. retry:
  1899.     if  (sc_conscnt > 0)  {
  1900.        oconsp = sc_consp;
  1901.        sc_consp->pair.car = x;
  1902.        sc_consp->pair.cdr = y;
  1903.        sc_consp = (SCP)(((int*)sc_consp)+2);
  1904.        sc_conscnt--;
  1905.        MUTEXOFF;
  1906.        return( U_T( oconsp, PAIRTAG ) );
  1907.     }
  1908.     allocatepage( 1, PAIRTAG );
  1909.     goto retry;
  1910. }
  1911.